   IOI. 9 (Bussines). Se considera un numar de cel mult 100 companii. Fiecare
din ele poate detine procente din actiunile oricarei alte companii. Fiind date
doua companii A si B, spunem ca A controleaza compania B daca cel putin una
din urmatoarele conditii este ndeplinita:
a) A=B;
b) A detine mai mult de 50% din B;
c) A controleaza k1 companii C(1),..,C(k), fiecare C(i) detine x(i)% din B si
x(1)+x(2)+..+x(k)>50.
    Se dau triplete (i,j,p) cu semnificatia: i detine p% din j. Se cer toate
perechile (h,s) astfel nct h controleaza compania s.
    Se cere sa se scrie un program care sa realizeze urmatoarele:
  1) Citeste dintr-un fisier de intrare lista tripletelor. Testele (seturile
consecutive de date) sunt separate ntre ele printr-o linie libera. Valorile
i,j,p sunt numere naturale;
  2) Determina toate perechile (h,s) astfel nct h controleaza s;
  3) Scrie n fisierul text de iesire toate perechile (h,s) determinate la
(2), cu h<s. Perechile (h,s) trebuiesc scrise n ordinea crescatoare a lui h.
Solutiile pentru seturi de date diferite vor fi separate printr-o linie goala.
Exemplu: Pentru fisierul de intrare
2 3 25
1 4 36
4 5 63
2 1 48
3 4 30
4 2 52
5 3 30

1 2 30
2 3 52
3 4 51
4 5 70
5 4 20
4 3 20
fisierul de iesire trebuie sa aiba forma:
4 2
4 3
4 5

2 3
2 4
2 5
3 4
3 5
4 5
===================================
Solutia 1 (Mihai Stroe):
    Nici aceasta problema nu este dificila, explicatia fiind faptul ca in
  ziua respectiva s-au dat 3 probleme.
    Pentru fiecare companie X se construieste un vector al actiunilor detinute
  din celelalte companii. Companiile controlate sunt introduse intr-un alt
  vector. Pentru fiecare companie Y controlata de X se adauga actiunile
  detinute de Y la cele detinute de X; daca apar noi companii controlate,
  ele sunt introduse in vectorul controlat de X si vor fi luate in calcul
  ulterior. In final se afiseaza perechile (X,Y).

var fi,fo:text;
    p,i,j,k,l,m,n:longint;
    s:string;
    a,proc:array[1..100,1..100]of byte;
    top:array[1..100]of byte;

procedure readdata;
begin
  fillchar(a,sizeof(a),0);
  fillchar(proc,sizeof(proc),0);
  fillchar(top,sizeof(top),0);
  n:=0;
  while not eoln(fi) do
    begin
      readln(fi,i,j,p);
      proc[i,j]:=p;
      if i>n then n:=i;
      if p>50 then
         begin
           inc(top[i]);
           a[i,top[i]]:=j;
         end;
    end;
  readln(fi);
end;

procedure solve;
begin
  for i:=1 to n do
      begin
        j:=1;
        while j<=top[i] do
          begin
            for k:=1 to n do
                begin
                  m:=0;
                  if proc[i,k]<=50 then m:=1;
                  proc[i,k]:=proc[i,k]+proc[a[i,j],k];
                  if (m=1)and(proc[i,k]>50) then
                     begin
                       inc(top[i]);
                       a[i,top[i]]:=k;
                     end;
                end;
            inc(j);
          end;
      end;
  for i:=1 to n do
      for j:=1 to n do
          if proc[i,j]>50 then writeln(fo,i,' ',j);
  writeln(fo);
end;

begin
  write('Type input file name ');
  readln(s);
  assign(fi,s);
  write('Type output file name ');
  readln(s);
  assign(fo,s);
  reset(fi);
  rewrite(fo);
  while not eof(fi)do
    begin
      readdata;
      solve;
    end;
  close(fi);
  close(fo);
end.
-----------------------------------------------
Solutia 2 (Mihai Badoiu):
Grad de dificultate: mediu
Tehnica folosita: Programare dinamica O(n*E) unde E este numarul de
muchi si n este numarul de noduri.
Comentarii:Daca as fi folosit lista as fi putut micsora
complexitatea. Problema se poate rezolva si in O(E) daca nu exista
cicluri, in urmatorul mod:
1) se sorteaza in ordine topologica (O(E))
2) se parcurge in ord. inv. nodurile si se verifica prin programare
dinamica care noduri leapartin.
Dezavantaje:
1) graful poate avea cicluri.
2) se cer perechile de noduri in ordine crescatoare iar alg. le
determina in ordine descrescatoare. Acest dezavantaj se poate
elimina usor fara sa modifica complexitatea
3) limita de 100 este foarte mica si O(n*E) este o complexitate
foarte buna. 

var
        fo:text;
        n:integer;
        v:array[1..100,1..100] of byte;
        v2:array[1..100,1..100] of byte;
        vs,t:array[1..100] of byte;

procedure init;
var
        i,j:integer;
begin
        for i:=1 to 100 do
                for j:=1 to 100 do
                begin
                        v[i,j]:=0;
                        v2[i,j]:=0;
                        end;
end;

procedure calcul;
var
        i,j,k:integer;
        b:boolean;
begin
        for i:=1 to n do
        begin
                for j:=1 to n do
                begin
                        vs[j]:=0;
                        t[j]:=0;
                        end;
                t[i]:=100;
                repeat
                        b:=true;
                        for j:=1 to n do
                        if (vs[j]=0) and (t[j]>50) then
                        begin
                                b:=false;
                                vs[j]:=1;
                                for k:=1 to n do
                                begin
                                        t[k]:=t[k]+v[j,k];
                                        end;
                                end;
                        until b;
                for j:=1 to n do
                        if (vs[j]=1) and (j<>i) then
                                writeln(fo,i,' ',j);
                end;
end;

procedure load;
var
        nume:string;
        f:text;
        i,j,k:integer;
begin
        write('fis int. = ');
        readln(nume);
        assign(f,nume);
        reset(f);
        write('fis out = ');
        readln(nume);
        assign(fo,nume);
        rewrite(fo);
        while not eof(f) do
        begin
                init;
                n:=0;
                while not eoln(f) do
                begin
                        readln(f,i,j,k);
                        if i>n then
                                n:=i;
                        if j>n then
                                n:=j;
                        v[i,j]:=k;
                        end;
                readln(f);
                writeln(fo);
                calcul;
                end;
        close(fo);
        close(f);
end;

begin
        load;
end.
-------------------------------
solutia 3 (Peter Szolt)
  Rezolvarea este simpa: cind gasesc o companie care inca nu apartine de alta
(numai de una poate sa apartine, pt. ca daca apartine de alta, aceasta trebuie
sa detine mai mult de jumate), dar trebie sa apartine, atunci adaug procetele
acestuia la toate care controleaza pe acesta, la contrololul contrololului,
si asa maideparte.
  Mi se pare, ca dupa precizarea din punctul a), in fisirul de iesire ar tre-
bui sa apare ca o companie controleaza pe sine insusi, dar din cauza ca in
exemplul dat nu era asa, nici eu n-am facut asa.

program IOI9;
const
  Rezultat='rezultat.out';
  Max=100;
var
 s,s2:string;
 f,g:text;
 k:integer;
 i,j,n:byte;
 x:integer;
 t:array[1..max,1..max] of byte;
 w:array[1..max] of byte;
 wm:array[1..max] of set of 1..max;

procedure calc;
var
  ok:boolean;
  i2:byte;
begin
  fillchar(w,sizeof(w),0);
  for i:=1 to n do wm[i]:=[i];
  repeat
    ok:=true;
    for i:=1 to n do if w[i]=0 then
      for j:=1 to n do if i<>j then
      if t[j,i]>50 then begin
        ok:=false;
        w[i]:=j;
        k:=j;
        repeat
          wm[k]:=wm[k]+wm[i];
          for i2:=1 to n do t[k,i2]:=t[k,i2]+t[i,i2];
          k:=w[k];
        until (k=0) or (k=i);
      end;
  until ok;
  for i:=1 to n do
    for j:=1 to n do if (j<>i) and (j in wm[i]) then writeln(g,i,' ',j);
  {se exclud perechile de forma A A, fiindca nici in exemlu nu sunt prezente}
  writeln(g);
  fillchar(t,sizeof(t),0);
  n:=0;
end;
function maxx(var i,j:byte):byte;
begin
  if i<j then maxx:=j else maxx:=i;
end;
begin
  write('Fisierul de intrare:');
  readln(s);
  assign(f,s);
  assign(g,Rezultat);
  reset(f);
  rewrite(g);
  fillchar(t,sizeof(t),0);
  n:=0;
  while not eof(f) do begin
    readln(f,s);
    if (s='') or eof(f) then calc else begin
      while s[1]=' ' do delete(s,1,1);
      x:=pos(' ',s);
      s2:=copy(s,1,x-1);
      s:=copy(s,x+1,byte(s[0])-x);
      val(s2,i,x);
      while s[1]=' ' do delete(s,1,1);
      x:=pos(' ',s);
      s2:=copy(s,1,x-1);
      s:=copy(s,x+1,byte(s[0])-x);
      val(s2,j,x);
      while s[1]=' ' do delete(s,1,1);
      s:=copy(s,x+1,byte(s[0])-x);
      val(s,k,x);
      t[i,j]:=k;
      n:=maxx(n,i);
      n:=maxx(n,j);
    end;

  end;
  close(f);
  close(g);
end.
--------------------------------------
Solutia 4 (Catalin Francu)
program Business;
{$B-,I-,R-,S-}
const NMax=100;
type BooleanVector=array[0..NMax] of Boolean;
     IntegerVector=array[0..NMax] of Integer;
     IntegerMatrix=array[1..NMax,1..NMax] of Integer;
var A:IntegerMatrix;
    Share:IntegerVector;
    Control:BooleanVector;
    N:Integer;
    InName,OutName:String;

procedure ReadData;
var i,j:Integer;
begin
  N:=0;
  for i:=1 to 100 do
    for j:=1 to 100 do
      A[i,j]:=0;
  while not Eoln do
    begin
      ReadLn(i,j,A[i,j]);
      if i>N then N:=i;
      if j>N then N:=j;
    end;
  if not Eof then ReadLn;
end;

procedure FindControls;
var i,j,k:Integer;
begin
  Control[0]:=False;
  Share[0]:=51; { Pentru cautarea cu santinela }
  for i:=1 to N do
    begin
      for j:=1 to N do begin
                         Share[j]:=A[i,j];
                         Control[j]:=False;
                       end;
      Control[i]:=True;
      repeat
        j:=N+1;
        repeat Dec(j)
        until (Share[j]>50) and not Control[j];
        if j>0 then begin
                      Control[j]:=True;
                      for k:=1 to N do Inc(Share[k],A[j,k]);
                    end;
      until j=0;
      for j:=1 to N do
        if (i<>j) and Control[j] then WriteLn(i,' ',j);
    end;
end;

begin
  Write('Numele fisierului de intrare: ');ReadLn(InName);
  Write('Numele fisierului de iesire: ');ReadLn(OutName);
  Assign(Input,InName);Reset(Input);
  Assign(Output,OutName);Rewrite(Output);
  while not Eof do
    begin
      ReadData;
      FindControls;
      WriteLn;
    end;
  Close(Input);Close(Output);
end.
----------------------------------------
Solutia mea:
Algoritm:
Datele problemei se introduc ntr-o matrice actiuni(n,n), definit[ astfel:
actiuni(i,j)=procentul de aciuni ale companiei j deinut de compania i
actiuni(i,i)=
  Algoritmul consider[ c[ n momentul n care compania i controleaz[ compania j, aceasta va ceda
toate aciunile sale lui i; formal aceasta se va reprezenta prin adunarea liniei j la linia i.
              pentru fiecare linie algoritmul se reia cu matricea actiuni iniial[.

1. pentru i:=1,n
   1.1. j:=0;

   1.2. repeta 
          1.2.1. j:=j+1;
          1.2.2. dac[ j>n atunci salt la 1.7.
        pana cand actiuni(i,j)[51,100]
   1.3. scrie 'i controleaza j'
   1.4. pentru k:=1,n
           actiuni(i,k):=actiuni(i,k)+actiuni(j,k)
   1.5. actiuni(i,j)=
   1.6. salt la 1.1.
   1.7. se reface matricea actiuni initiala
2. Stop
Program:
var grila:array[1..100,1..100] of byte;
    studiat:array[1..100,1..100] of boolean;
    input,output:text;
    i,j,nr,a,b,x:integer;
    repeta:boolean;
begin
assign(input,'input.io9');
assign(output,'output.io9');
reset(input);
rewrite(output);
while not eof(input) do
      begin
      nr:=0;
      for i:=1 to 100 do for j:=1 to 100 do grila[i,j]:=0;
      for i:=1 to nr do for j:=1 to nr do studiat[i,j]:=false;
      while (not eoln(input)) and (not eof(input)) do
            begin
            readln(input,a,b,x);
            inc(nr);
            grila[a,b]:=x;
            end;
      repeat
            repeta:=false;
            for i:=1 to nr do
                for j:=1 to nr do
                    if (i<>j) and (grila[i,j]>=50) and (not studiat[i,j]) then
                       begin
                       for x:=1 to nr do grila[i,x]:=grila[i,x]+grila[j,x];
                       studiat[i,j]:=true;
                       repeta:=true;
                       end;
      until not repeta;
      for i:=1 to nr do for j:=1 to nr do if (i<>j) and (grila[i,j]>=50) then
writeln(output,i,' ',j);
      if eoln(input) then readln(input);
      writeln(output);
      end;
close(input);
close(output);
end.
-------------------------------------------------
